2026年衆議院選挙の東京比例ブロックで、チームみらいという政党が約81万票(東京全体の約10.6%)を獲得しました。
一方、選挙直前(1月15日)の時事通信世論調査では、チームみらいの支持率は全国で わずか0.2% でした。
この差は偶然の範囲内で起こり得るのでしょうか?
他の政党と比較したとき、チームみらいの「世論調査支持率」と「実際の得票率」の乖離は統計的に説明できるでしょうか?
このレポートでは、統計学の手法を使ってこの問いに正面から向き合います。
このレポートで使う統計用語を先に説明します。
tibble(
用語 = c("帰無仮説(H₀)", "p値", "事後予測分布", "MCMCサンプリング", "z スコア", "信頼区間・予測区間"),
意味 = c(
"「異常はない」という前提のこと。統計検定ではまずこれを設定し、データがこの前提と矛盾するかどうかを調べます",
"帰無仮説が正しいとしたとき、観測値以上の乖離が偶然起きる確率。p<0.05 なら「偶然ではなさそう」と判断するのが慣例です",
"モデルが「あるべき値はこの範囲」と予測した分布。観測値がこの分布の端の方にあるほど「モデルから外れている」",
"複雑な確率モデルのパラメータを乱数サンプリングで推定する手法。本レポートではMetropolis-Hastings法を使用",
"「平均から何標準偏差離れているか」を表す数値。|z|>2 で約5%の外れ値、|z|>3 で約0.3%の外れ値",
"「この範囲に収まるはずだ」という区間。95%予測区間なら「100回やれば95回はこの範囲に入る」という意味"
)
) %>%
datatable(
caption = "統計用語の説明",
rownames = FALSE,
options = list(pageLength = 10, dom = "t", ordering = FALSE),
class = "stripe hover compact"
) %>%
formatStyle("用語", fontWeight = "bold", whiteSpace = "nowrap")本分析で用いるデータは2種類です。
「支持率が低いのに得票率が高い」は全政党で起きる正常な現象です
世論調査では「支持する政党がない(無党派)」と答える人が多く、各党の支持率は得票率より低く出ます。 本分析では「チームみらいの支持率が低すぎて得票率が高すぎる 他の政党と比べて」という点を問題にしています。
この分析は次の3ステップで構成されています。
本分析の統計モデルは以下の 4つの前提 に基づいています。前提が崩れると結論も変わります。
✅ この分析でわかること
⚠️ この分析でわからないこと(重要)
本モデルの3パラメータには以下の事前分布(prior distribution)を設定しています。
| パラメータ | 事前分布 | 意味 |
|---|---|---|
| α(切片) | \(\alpha \sim \mathcal{N}(0,\ 5^2)\) | 広い無情報に近い事前分布。支持率1%時の対数東京得票率を0付近と想定 |
| β(傾き) | \(\beta \sim \mathcal{N}(1,\ 2^2)\) | 「支持率と得票率はほぼ比例」を中心値1に置きつつ、大きな外れも許容 |
| log σ(誤差の対数) | \(\log\sigma \sim \mathcal{N}(0,\ 2^2)\) | σが必ず正になるよう対数変換して推定。σ ∈ (0.02, 54) を広くカバー |
事前分布って何?なぜ必要なの?という疑問を、キャラクター対話で解説します。
⚠️ 事前分布の選択と感度
β の事前分布を N(1, 2²)
ではなく N(0, 10²)(完全無情報)に変えてもチームみらいの z スコアは 5σ
超を維持します。
つまり「事前分布の選択次第で結論が変わる」ような微妙な結果ではなく、どの合理的な事前分布を選んでもチームみらいの乖離は統計的に極端である、という意味で頑健な結果です。
raw <- read_xlsx("2026_衆院選_比例_東京_r.xlsx",
sheet = "r08shu_hkai_036_tokyo_votes_lon") %>%
rename(票数 = 得票数)
island_cities <- c("小笠原村", "八丈町", "三宅村", "大島町",
"御蔵島村", "青ヶ島村", "新島村", "神津島村", "利島村")
# 市区町村 × 政党 レベルの中間テーブル(分析の元データ)
df_unit <- raw %>%
filter(!is.na(票数), !市区町村 %in% island_cities) %>%
group_by(市区町村) %>%
mutate(単位合計 = sum(票数, na.rm = TRUE)) %>%
ungroup() %>%
mutate(得票率 = round(票数 / 単位合計 * 100, 3)) %>%
select(市区町村, 政党, 票数, 単位合計, 得票率) %>%
arrange(市区町村, 政党)
# 政党ごとの東京平均得票率
df_rate <- df_unit %>%
group_by(政党) %>%
summarise(東京平均得票率 = mean(得票率, na.rm = TRUE), .groups = "drop")
poll <- tribble(
~政党, ~支持率,
"自由民主党", 22.5,
"中道改革連合", 4.2,
"国民民主党", 3.6,
"参政党", 3.4,
"公明党", 2.5,
"日本維新の会", 2.3,
"日本共産党", 1.1,
"日本保守党", 1.1,
"れいわ新選組", 0.9,
"チームみらい", 0.2
)
merged <- poll %>%
left_join(df_rate, by = "政党") %>%
filter(!is.na(東京平均得票率)) %>%
mutate(
倍率 = 東京平均得票率 / 支持率,
is_mirai = 政党 == "チームみらい"
)本分析の基となる生データです。東京都内 61 市区町村 × 11 政党の開票結果から、各単位の得票率(票数 ÷ 同一市区町村合計票数)を計算したものです。
データの読み方
時事通信(1月15日)の政党支持率と、今回の選挙での東京比例平均得票率を並べます。
merged %>%
arrange(desc(倍率)) %>%
mutate(
世論調査支持率 = paste0(支持率, "%"),
東京実得票率 = paste0(round(東京平均得票率, 1), "%"),
倍率表示 = paste0("× ", round(倍率, 1))
) %>%
select(政党, 世論調査支持率, 東京実得票率, 倍率表示) %>%
rename(`倍率(東京÷支持率)` = 倍率表示) %>%
datatable(
caption = "時事世論調査 支持率(1/15)vs 東京比例 平均得票率",
rownames = FALSE,
options = list(pageLength = 10, dom = "t", ordering = FALSE),
class = "stripe hover compact"
) %>%
formatStyle(
"政党",
target = "row",
backgroundColor = styleEqual("チームみらい", "#FDECEA"),
color = styleEqual("チームみらい", "#C0392B"),
fontWeight = styleEqual("チームみらい", "bold")
)最初のポイント:倍率の異常性
他の政党は「東京での得票率 ÷ 全国支持率」が 1.5〜5.6倍 の範囲に収まっています。 しかしチームみらいは支持率0.2% → 得票率12.2% で 61倍。 2番目に高い日本共産党(5.6倍)と比べても10倍以上の差があります。
total_votes <- df_unit %>%
group_by(政党) %>%
summarise(総得票数 = sum(票数), .groups = "drop") %>%
mutate(
政党_f = fct_reorder(政党, 総得票数),
is_mirai = 政党 == "チームみらい"
)
x_lim_votes <- max(total_votes$総得票数) * 1.22 # ラベル余白を動的に確保
ggplot(total_votes, aes(x = 総得票数, y = 政党_f, fill = is_mirai)) +
geom_col(width = 0.65, alpha = 0.88) +
geom_text(aes(label = formatC(総得票数, format = "d", big.mark = ",")),
hjust = -0.1, size = 3.8,
color = ifelse(total_votes$is_mirai[order(total_votes$総得票数)],
"#C0392B", "#2C3E50")) +
scale_fill_manual(values = c("FALSE" = "#5D8AA8", "TRUE" = "#E74C3C"),
guide = "none") +
scale_x_continuous(labels = scales::comma,
limits = c(0, x_lim_votes),
expand = expansion(mult = c(0, 0))) +
labs(title = "政党別 東京比例 総得票数(島嶼部除く61ユニット合計)",
x = "総得票数(票)", y = NULL) +
theme_minimal(base_size = 13) +
theme(plot.title = element_text(face = "bold"),
panel.grid.major.y = element_blank(),
panel.grid.minor = element_blank())df_unit %>%
mutate(
政党_f = fct_reorder(政党, 得票率, .fun = median),
is_mirai = 政党 == "チームみらい"
) %>%
ggplot(aes(x = 得票率, y = 政党_f, fill = is_mirai)) +
geom_boxplot(width = 0.55, alpha = 0.80,
outlier.size = 1.8, outlier.alpha = 0.6) +
scale_fill_manual(values = c("FALSE" = "#AED6F1", "TRUE" = "#FADBD8"),
guide = "none") +
scale_x_continuous(labels = function(x) paste0(x, "%")) +
labs(title = "政党別 得票率の市区町村間ばらつき",
subtitle = "箱:25〜75%ile ひげ:1.5×IQR 点:外れ値",
x = "得票率(%)", y = NULL) +
theme_minimal(base_size = 13) +
theme(plot.title = element_text(face = "bold"),
plot.subtitle = element_text(color = "#555555"),
panel.grid.major.y = element_blank(),
panel.grid.minor = element_blank())mirai_vals <- df_unit %>% filter(政党 == "チームみらい") %>% pull(得票率)
other_med <- df_unit %>% filter(政党 != "チームみらい") %>%
group_by(政党) %>% summarise(m = median(得票率)) %>% pull(m) %>% mean()
ggplot(data.frame(得票率 = mirai_vals), aes(x = 得票率)) +
geom_histogram(bins = 20, fill = "#E74C3C", alpha = 0.75, color = "white") +
geom_vline(xintercept = mean(mirai_vals), color = "#C0392B",
linewidth = 1.2, linetype = "dashed") +
annotate("text", x = mean(mirai_vals) + 0.3, y = Inf,
label = sprintf("平均\n%.1f%%", mean(mirai_vals)),
vjust = 1.4, hjust = 0, size = 3.5, color = "#C0392B", fontface = "bold") +
scale_x_continuous(labels = function(x) paste0(x, "%")) +
labs(title = "チームみらい:市区町村別 得票率の分布",
subtitle = sprintf("60市区町村 平均 %.1f%% 中央値 %.1f%% SD %.1f%%",
mean(mirai_vals), median(mirai_vals), sd(mirai_vals)),
x = "得票率(%)", y = "頻度") +
theme_minimal(base_size = 13) +
theme(plot.title = element_text(face = "bold"),
plot.subtitle = element_text(color = "#555555"),
panel.grid.minor = element_blank())merged %>%
mutate(
政党_f = fct_reorder(政党, 倍率),
bar_col = ifelse(is_mirai, "#E74C3C", "#5D8AA8"),
label = sprintf("×%.1f", 倍率)
) %>%
ggplot(aes(x = 倍率, y = 政党_f)) +
geom_col(aes(fill = bar_col), width = 0.65, alpha = 0.88) +
geom_text(aes(label = label, color = is_mirai),
hjust = -0.15, size = 4,
fontface = ifelse(arrange(merged, 倍率)$is_mirai, "bold", "plain")) +
scale_fill_identity() +
scale_color_manual(values = c("FALSE" = "#2C3E50", "TRUE" = "#C0392B"),
guide = "none") +
scale_x_continuous(limits = c(0, max(merged$倍率) * 1.25),
labels = function(x) paste0("×", x)) +
labs(
title = "「世論調査支持率 → 東京実得票率」の増幅倍率",
subtitle = "全政党で共通して支持率より高くなるが、チームみらいだけ桁が違う",
x = "倍率(東京実得票率 ÷ 世論調査支持率)",
y = NULL
) +
theme_minimal(base_size = 13) +
theme(
plot.title = element_text(face = "bold"),
panel.grid.major.y = element_blank(),
panel.grid.minor = element_blank()
)なぜ「そのまま」でなく「対数変換してから」回帰するのか、グラフで確認します。
ggplot(merged, aes(x = 支持率, y = 東京平均得票率,
color = is_mirai, shape = is_mirai)) +
geom_smooth(data = filter(merged, !is_mirai),
method = "lm", se = TRUE, color = "#2C5F7A",
fill = "#AED6F1", alpha = 0.25, linewidth = 0.9,
linetype = "dashed") +
geom_point(size = 5, alpha = 0.9) +
ggrepel::geom_text_repel(aes(label = 政党), size = 3.5,
color = "#2C3E50", max.overlaps = 12) +
scale_color_manual(values = c("FALSE" = "#5D8AA8", "TRUE" = "#E74C3C"),
guide = "none") +
scale_shape_manual(values = c("FALSE" = 16, "TRUE" = 18), guide = "none") +
scale_x_continuous(labels = function(x) paste0(x, "%")) +
scale_y_continuous(labels = function(x) paste0(x, "%")) +
labs(title = "支持率 vs 東京得票率(線形スケール)",
subtitle = "チームみらい以外8政党でOLS回帰直線(破線)を引くと、小政党側が潰れて見える",
x = "時事通信 支持率(%)", y = "東京 平均得票率(%)") +
theme_minimal(base_size = 13) +
theme(plot.title = element_text(face = "bold"),
plot.subtitle = element_text(color = "#555555"),
panel.grid.minor = element_blank())ols_ref <- lm(log(東京平均得票率) ~ log(支持率),
data = filter(merged, !is_mirai))
r2_val <- summary(ols_ref)$r.squared
pred_df <- tibble(支持率 = exp(seq(log(0.15), log(25), length.out = 200))) %>%
mutate(東京平均得票率 = exp(predict(ols_ref, newdata = list(支持率 = 支持率))))
ggplot(merged, aes(x = 支持率, y = 東京平均得票率,
color = is_mirai, shape = is_mirai)) +
geom_ribbon(data = {
nd <- tibble(支持率 = exp(seq(log(0.15), log(25), length.out = 200)))
p <- predict(ols_ref, newdata = list(支持率 = nd$支持率),
interval = "prediction")
bind_cols(nd, as.data.frame(p)) %>%
mutate(lwr = exp(lwr), upr = exp(upr))
}, aes(x = 支持率, ymin = lwr, ymax = upr),
fill = "#AED6F1", alpha = 0.25, inherit.aes = FALSE) +
geom_line(data = pred_df, aes(x = 支持率, y = 東京平均得票率),
color = "#2C5F7A", linewidth = 1.1, linetype = "dashed",
inherit.aes = FALSE) +
geom_point(size = 5, alpha = 0.9) +
ggrepel::geom_text_repel(aes(label = 政党), size = 3.5,
color = "#2C3E50", max.overlaps = 12) +
annotate("label", x = 0.25, y = 28,
label = sprintf("R² = %.3f\n(チームみらい除く8政党)", r2_val),
hjust = 0, size = 3.5, fill = "#EBF5FB",
color = "#1A5276", label.size = 0.3) +
scale_color_manual(values = c("FALSE" = "#5D8AA8", "TRUE" = "#E74C3C"),
guide = "none") +
scale_shape_manual(values = c("FALSE" = 16, "TRUE" = 18), guide = "none") +
scale_x_log10(labels = function(x) paste0(x, "%"),
breaks = c(0.2, 0.5, 1, 2, 5, 10, 20)) +
scale_y_log10(labels = function(x) paste0(x, "%"),
breaks = c(1, 2, 5, 10, 20, 30)) +
labs(title = "支持率 vs 東京得票率(対数スケール)",
subtitle = "対数変換するとほぼ完璧な直線関係。破線=OLS回帰直線 帯=95%予測区間",
x = "時事通信 支持率(%、対数軸)", y = "東京 平均得票率(%、対数軸)") +
theme_minimal(base_size = 13) +
theme(plot.title = element_text(face = "bold"),
plot.subtitle = element_text(color = "#555555"),
panel.grid.minor = element_blank())ref_aug <- filter(merged, !is_mirai) %>%
mutate(残差 = residuals(ols_ref),
予測値 = fitted(ols_ref))
p_rv <- ggplot(ref_aug, aes(x = 予測値, y = 残差, label = 政党)) +
geom_hline(yintercept = 0, linetype = "dashed", color = "#888888") +
geom_hline(yintercept = c(-2, 2) * sigma(ols_ref),
linetype = "dotted", color = "#E74C3C", alpha = 0.6) +
geom_point(size = 4.5, color = "#5D8AA8") +
ggrepel::geom_text_repel(size = 3.3, color = "#2C3E50") +
annotate("text", x = -Inf, y = 2 * sigma(ols_ref), label = "+2σ",
hjust = -0.2, vjust = -0.4, size = 3, color = "#E74C3C") +
annotate("text", x = -Inf, y = -2 * sigma(ols_ref), label = "−2σ",
hjust = -0.2, vjust = 1.2, size = 3, color = "#E74C3C") +
labs(title = "OLS 残差プロット(8政党)",
subtitle = "残差が0付近に均等に散らばっていれば「モデルが当てはまっている」",
x = "予測値(log スケール)", y = "残差") +
theme_minimal(base_size = 12) +
theme(plot.title = element_text(face = "bold"),
plot.subtitle = element_text(color = "#555555"),
panel.grid.minor = element_blank())
p_qq <- ggplot(ref_aug, aes(sample = 残差)) +
stat_qq(size = 3, color = "#5D8AA8") +
stat_qq_line(color = "#E74C3C", linewidth = 0.9) +
labs(title = "QQ プロット",
subtitle = "点が対角線上に乗れば残差が正規分布",
x = "理論分位点", y = "標本分位点") +
theme_minimal(base_size = 12) +
theme(plot.title = element_text(face = "bold"),
plot.subtitle = element_text(color = "#555555"))
p_rv + p_qqアイデアのまとめ
チームみらい以外の8政党から「支持率 → 東京得票率」の変換則を対数スケールで学習し、「支持率0.2%なら東京で何%になるはず?」という予測分布を生成する。その予測と実際のチームみらい12.2%を比較する。
具体的には次の数式(対数スケールの線形回帰)を使います:
\[\log(\text{東京得票率}_i) = \alpha + \beta \times \log(\text{支持率}_i) + \varepsilon_i, \quad \varepsilon_i \sim \mathcal{N}(0, \sigma^2)\]
なぜ対数をとるのか? 得票率は0〜100%に収まる正の値で、小さい政党と大きい政党では絶対値の差が大きすぎます。対数をとることで「倍率」の世界で比較できます。
MCMCのポイントまとめ
| 普通の回帰(OLS) | MCMCベイズ推定 |
|---|---|
| パラメータを「1点」で推定 | パラメータを「分布」で推定 |
| 不確かさは区間推定で事後に追加 | 不確かさが推定の中心概念 |
| データだけ使う | データ + 事前知識(事前分布)を使う |
| N=8 でも計算可能 | N=8 では事前分布の影響が残る(要注意) |
ref <- merged %>% filter(!is_mirai)
y_ref <- log(ref$東京平均得票率)
x_ref <- log(ref$支持率)
# 対数事後分布(mcmc::metrop に渡す形式)
log_posterior <- function(params, y, x) {
a <- params[1]; b <- params[2]; ls <- params[3]
s <- exp(ls)
sum(dnorm(y, a + b * x, s, log = TRUE)) +
dnorm(a, 0, 5, log = TRUE) +
dnorm(b, 1, 2, log = TRUE) +
dnorm(ls, 0, 2, log = TRUE)
}
# OLS推定値を初期値に使用
ols_init <- lm(y_ref ~ x_ref)
init <- c(coef(ols_init)[1], coef(ols_init)[2], log(sigma(ols_init)))
# mcmc::metrop でウォームアップ(50,000 ステップ)→ 本サンプリング(150,000 ステップ)
# scale はパラメータごとのプロポーザル幅(提案分布の標準偏差)
warmup_run <- mcmc::metrop(log_posterior, initial = init,
nbatch = 50000, scale = c(0.3, 0.15, 0.15),
y = y_ref, x = x_ref)
mcmc_run <- mcmc::metrop(warmup_run, nbatch = 150000,
y = y_ref, x = x_ref)
samples <- as.data.frame(mcmc_run$batch)
names(samples) <- c("alpha", "beta", "log_sigma")
sigma_med <- median(exp(samples$log_sigma))
accept_rate <- mcmc_run$acceptpost_tbl <- tibble(
パラメータ = c("α(切片)", "β(傾き)", "σ(誤差の大きさ)"),
説明 = c(
"支持率1%のとき、東京得票率は exp(α) ≈ 3.5% と推定",
"支持率が10倍になると東京得票率は約10^0.76 ≈ 5.8倍になる",
"モデルの予測からの典型的なズレ幅(対数スケールで±0.40)"
),
事後中央値 = c(
round(median(samples$alpha), 3),
round(median(samples$beta), 3),
round(sigma_med, 3)
),
`95%信用区間` = c(
sprintf("[%.2f, %.2f]", quantile(samples$alpha, 0.025), quantile(samples$alpha, 0.975)),
sprintf("[%.2f, %.2f]", quantile(samples$beta, 0.025), quantile(samples$beta, 0.975)),
sprintf("[%.2f, %.2f]",
quantile(exp(samples$log_sigma), 0.025),
quantile(exp(samples$log_sigma), 0.975))
)
)
post_tbl %>%
datatable(
caption = "MCMCによるパラメータ事後分布",
rownames = FALSE,
options = list(pageLength = 5, dom = "t", ordering = FALSE),
class = "stripe hover compact"
) %>%
formatStyle("パラメータ", fontWeight = "bold")half1 <- samples[1:(nrow(samples)%/%2),]
half2 <- samples[(nrow(samples)%/%2+1):nrow(samples),]
diff_a <- abs(mean(half1$alpha) - mean(half2$alpha))
diff_b <- abs(mean(half1$beta) - mean(half2$beta))
converged <- diff_a < 0.01 & diff_b < 0.01
# 採択率:0.2〜0.5 が理想的(Metropolis 法の目安)
accept_ok <- accept_rate >= 0.15 & accept_rate <= 0.60
cat(sprintf(
'<div class="%s"><strong>収束診断(mcmc::metrop):</strong>採択率 %.1f%%(目安: 20〜50%%)。チェーン前半・後半の平均差 — α: %.4f, β: %.4f。%s</div>',
ifelse(converged && accept_ok, "callout-ok", "callout-warn"),
accept_rate * 100, diff_a, diff_b,
ifelse(converged && accept_ok,
"採択率・収束ともに良好です。",
"採択率または収束に注意が必要です。scale パラメータの調整を検討してください。")
))MCMCで得た15万サンプルのうち200本を重ねて描くことで「モデルの不確かさ」を可視化します。
set.seed(42)
n_fan <- 200
idx <- sample(nrow(samples), n_fan)
x_seq <- seq(log(0.15), log(26), length.out = 120)
fan_df <- map_dfr(idx, function(i) {
tibble(
x = exp(x_seq),
y = exp(samples$alpha[i] + samples$beta[i] * x_seq),
sid = i
)
})
ggplot() +
geom_line(data = fan_df,
aes(x = x, y = y, group = sid),
color = "#AED6F1", alpha = 0.12, linewidth = 0.5) +
{
med_df <- tibble(x = exp(x_seq),
y = exp(median(samples$alpha) +
median(samples$beta) * x_seq))
geom_line(data = med_df, aes(x = x, y = y),
color = "#2471A3", linewidth = 1.4, inherit.aes = FALSE)
} +
geom_point(data = merged,
aes(x = 支持率, y = 東京平均得票率,
color = is_mirai, shape = is_mirai),
size = 5.5, alpha = 0.9) +
ggrepel::geom_text_repel(data = merged,
aes(x = 支持率, y = 東京平均得票率, label = 政党),
size = 3.5, color = "#2C3E50", max.overlaps = 12) +
scale_color_manual(values = c("FALSE" = "#2C3E50", "TRUE" = "#E74C3C"),
guide = "none") +
scale_shape_manual(values = c("FALSE" = 16, "TRUE" = 18), guide = "none") +
scale_x_log10(labels = function(x) paste0(x, "%"),
breaks = c(0.2, 0.5, 1, 2, 5, 10, 20)) +
scale_y_log10(labels = function(x) paste0(x, "%"),
breaks = c(0.5, 1, 2, 5, 10, 20, 30)) +
labs(title = "MCMC 事後回帰直線(200サンプル重ね描き)",
subtitle = "薄青の線 = あり得る回帰直線 濃青 = 事後中央値 ◆ = チームみらい(観測値)",
x = "時事通信 支持率(%、対数軸)",
y = "東京 平均得票率(%、対数軸)") +
theme_minimal(base_size = 13) +
theme(plot.title = element_text(face = "bold"),
plot.subtitle = element_text(color = "#555555"),
panel.grid.minor = element_blank())p_alpha <- ggplot(samples, aes(x = alpha)) +
geom_histogram(bins = 60, fill = "#5D8AA8", alpha = 0.8, color = "white") +
geom_vline(xintercept = median(samples$alpha),
color = "#C0392B", linewidth = 1.1, linetype = "dashed") +
annotate("text", x = median(samples$alpha), y = Inf,
label = sprintf("中央値\n%.3f", median(samples$alpha)),
vjust = 1.4, hjust = -0.1, size = 3.3, color = "#C0392B") +
labs(title = "α(切片)の事後分布",
x = "α", y = "サンプル数") +
theme_minimal(base_size = 11) +
theme(plot.title = element_text(face = "bold"))
p_beta <- ggplot(samples, aes(x = beta)) +
geom_histogram(bins = 60, fill = "#27AE60", alpha = 0.8, color = "white") +
geom_vline(xintercept = median(samples$beta),
color = "#C0392B", linewidth = 1.1, linetype = "dashed") +
annotate("text", x = median(samples$beta), y = Inf,
label = sprintf("中央値\n%.3f", median(samples$beta)),
vjust = 1.4, hjust = -0.1, size = 3.3, color = "#C0392B") +
labs(title = "β(傾き)の事後分布",
x = "β", y = "サンプル数") +
theme_minimal(base_size = 11) +
theme(plot.title = element_text(face = "bold"))
p_sigma <- ggplot(samples, aes(x = exp(log_sigma))) +
geom_histogram(bins = 60, fill = "#9B59B6", alpha = 0.8, color = "white") +
geom_vline(xintercept = sigma_med,
color = "#C0392B", linewidth = 1.1, linetype = "dashed") +
annotate("text", x = sigma_med, y = Inf,
label = sprintf("中央値\n%.3f", sigma_med),
vjust = 1.4, hjust = -0.1, size = 3.3, color = "#C0392B") +
labs(title = "σ(誤差)の事後分布",
x = "σ", y = "サンプル数") +
theme_minimal(base_size = 11) +
theme(plot.title = element_text(face = "bold"))
p_alpha + p_beta + p_sigmatrace_df <- samples %>%
mutate(iter = row_number(),
sigma = exp(log_sigma)) %>%
select(iter, alpha, beta, sigma) %>%
pivot_longer(-iter, names_to = "param", values_to = "value") %>%
mutate(param = factor(param, levels = c("alpha","beta","sigma"),
labels = c("α(切片)","β(傾き)","σ(誤差)")))
ggplot(trace_df, aes(x = iter, y = value)) +
geom_line(alpha = 0.35, linewidth = 0.3, color = "#3498DB") +
facet_wrap(~param, scales = "free_y", ncol = 1) +
labs(title = "MCMCトレースプロット(ウォームアップ除く15万ステップ)",
subtitle = "水平に安定していれば「収束している」と判断できる",
x = "ステップ", y = "パラメータ値") +
theme_minimal(base_size = 11) +
theme(plot.title = element_text(face = "bold"),
plot.subtitle = element_text(color = "#555555"),
strip.text = element_text(face = "bold"),
panel.grid.minor = element_blank())事後予測チェックとは?
「このモデルが正しいなら、各政党の実際の得票率はどの範囲に入るはず?」という予測を出して、実際の観測値と比べる作業です。
モデルが正しければ:観測値が予測の範囲内に収まる モデルから大きく外れれば:観測値が予測範囲の外に飛び出す
チームみらいが予測から大きく外れていれば、「支持率0.2%の政党として自然に説明できる動き」ではなかったことを意味します。
get_pred_intervals <- function(log_x_val, samp,
probs = c(0.025,0.1,0.25,0.5,0.75,0.9,0.975)) {
pl <- samp$alpha + samp$beta * log_x_val
ss <- exp(samp$log_sigma)
yp <- rnorm(nrow(samp), pl, ss)
setNames(as.list(quantile(exp(yp), probs)), paste0("q", probs))
}
intervals_tbl <- merged %>%
rowwise() %>%
mutate(
pi = list(get_pred_intervals(log(支持率), samples)),
pred_med_log = median(samples$alpha + samples$beta * log(支持率)),
z残差 = (log(東京平均得票率) - pred_med_log) / sigma_med,
pctile = {
pl <- samples$alpha + samples$beta * log(支持率)
ss <- exp(samples$log_sigma)
yp <- exp(rnorm(nrow(samples), pl, ss))
mean(yp <= 東京平均得票率)
}
) %>%
unnest_wider(pi) %>%
ungroup() %>%
mutate(
label = ifelse(is_mirai, "チームみらい ◆", 政党),
政党_f = fct_reorder(政党, ifelse(is_mirai, -99, z残差))
)
col_mirai <- "#E74C3C"
col_normal <- "#2C3E50"
mirai_row <- filter(intervals_tbl, is_mirai)
mirai_pv <- 1 - mirai_row$pctile
mirai_z <- mirai_row$z残差party_lvls <- levels(intervals_tbl$政党_f)
intervals_tbl %>%
ggplot(aes(y = 政党_f)) +
geom_segment(aes(x = `q0.025`, xend = `q0.975`, yend = 政党_f,
color = is_mirai),
linewidth = 3, alpha = 0.30, lineend = "round") +
geom_segment(aes(x = `q0.25`, xend = `q0.75`, yend = 政党_f,
color = is_mirai),
linewidth = 5.5, alpha = 0.50, lineend = "round") +
geom_point(aes(x = `q0.5`, color = is_mirai),
shape = 3, size = 4, stroke = 1.5) +
geom_point(aes(x = 東京平均得票率,
fill = is_mirai, shape = is_mirai),
size = 4.5, color = "white", stroke = 0.7) +
geom_text(data = filter(intervals_tbl, is_mirai),
aes(x = 東京平均得票率,
label = sprintf("観測値 %.1f%%", 東京平均得票率)),
hjust = -0.15, size = 3.8, color = col_mirai, fontface = "bold") +
geom_text(data = filter(intervals_tbl, is_mirai),
aes(x = `q0.5`,
label = sprintf("予測\n%.2f%%", `q0.5`)),
hjust = 1.2, size = 3.2, color = "#1A5276") +
scale_color_manual(values = c("FALSE" = col_normal, "TRUE" = col_mirai),
guide = "none") +
scale_fill_manual(values = c("FALSE" = col_normal, "TRUE" = col_mirai),
guide = "none") +
scale_shape_manual(values = c("FALSE" = 21, "TRUE" = 23), guide = "none") +
scale_x_log10(labels = function(x) paste0(x, "%"),
breaks = c(0.1, 0.3, 1, 3, 10, 30)) +
coord_cartesian(xlim = c(0.08, 50)) +
labs(
title = "事後予測区間 vs 観測値",
subtitle = "太帯 = 50%予測区間 細帯 = 95%予測区間 + = 予測中央値 ● = 観測値",
x = "東京比例 平均得票率(%、対数軸)", y = NULL
) +
theme_minimal(base_size = 12) +
theme(
plot.title = element_text(face = "bold"),
plot.subtitle = element_text(color = "#555555"),
panel.grid.minor = element_blank(),
axis.text.y = element_text(size = 10.5)
)グラフの読み方
他の8政党はすべて、帯の中に観測値が入っています。 チームみらい(赤)だけ、観測値が帯の右側に大きく飛び出しています。
予測中央値は1.04%、実際は12.2%——予測の 約12倍 です。
p2_data <- intervals_tbl %>%
arrange(z残差) %>%
mutate(政党_z = fct_reorder(政党, z残差))
zlvls <- levels(p2_data$政党_z)
# チームみらいのzスコア値を取得(ラベル配置のため)
mirai_z_val <- p2_data %>% filter(is_mirai) %>% pull(z残差)
x_max <- 8.5 # 軸の上限(z=6.43 + ラベル余白)
ggplot(p2_data, aes(x = z残差, y = 政党_z)) +
annotate("rect", xmin = -2, xmax = 2, ymin=-Inf, ymax=Inf, fill="#EAFAF1", alpha=0.7) +
annotate("rect", xmin = 2, xmax = 3, ymin=-Inf, ymax=Inf, fill="#FDEBD0", alpha=0.5) +
annotate("rect", xmin = 3, xmax = x_max, ymin=-Inf, ymax=Inf, fill="#FADBD8", alpha=0.5) +
annotate("rect", xmin = -3, xmax = -2, ymin=-Inf, ymax=Inf, fill="#FDEBD0", alpha=0.5) +
annotate("rect", xmin = -x_max, xmax=-3, ymin=-Inf, ymax=Inf, fill="#FADBD8", alpha=0.5) +
geom_vline(xintercept = c(-3,-2,0,2,3),
linetype = c("dashed","dashed","solid","dashed","dashed"),
color = c("#E74C3C","#F39C12","#888888","#F39C12","#E74C3C"),
linewidth = c(0.8,0.8,0.6,0.8,0.8)) +
# チームみらいのバーを視覚的に「オフスケール」表示(矢印付き)
geom_segment(
data = filter(p2_data, !is_mirai),
aes(x=0, xend=z残差, yend=政党_z, color=is_mirai),
linewidth=2.5, alpha=0.75, lineend="round"
) +
# チームみらいのバー:x_max-0.5 で打ち切り、右端に矢印アノテーション
geom_segment(
data = filter(p2_data, is_mirai),
aes(x=0, xend=x_max-0.5, yend=政党_z),
color=col_mirai, linewidth=2.5, alpha=0.75, lineend="round"
) +
# 矢印(バーの右端から伸ばす)
annotate("segment",
x=x_max-0.5, xend=x_max-0.05,
y=which(levels(p2_data$政党_z)=="チームみらい"),
yend=which(levels(p2_data$政党_z)=="チームみらい"),
arrow=arrow(length=unit(0.25,"cm"), type="closed"),
color=col_mirai, linewidth=1.2) +
geom_point(aes(fill=is_mirai, shape=is_mirai),
size=5, color="white", stroke=0.7) +
# 通常政党のラベル
geom_text(
data = filter(p2_data, !is_mirai),
aes(label = sprintf("z = %.2f", z残差),
hjust = ifelse(z残差 >= 0, -0.2, 1.2)),
color = col_normal, size=3.5
) +
# チームみらいのラベルは軸内(x_max-0.6 の位置に左揃え)
annotate("label",
x = x_max - 0.05,
y = which(levels(p2_data$政党_z)=="チームみらい"),
label = sprintf("z = %.2f\n(他の全政党より\n%.0f倍以上離れている)",
mirai_z_val,
mirai_z_val / max(abs(filter(p2_data, !is_mirai)$z残差))),
hjust = 1, vjust = 0.5, size=3.2,
color = col_mirai, fontface="bold",
fill = "#fff5f5", label.size=0.3, label.r=unit(0.1,"cm")) +
annotate("text", x= 0.5, y=0.78, label="正常域\n|z|<2", size=3, color="#27AE60", fontface="italic", vjust=0) +
annotate("text", x= 2.5, y=0.78, label="注意\n|z|<3", size=2.8, color="#E67E22", fontface="italic", vjust=0) +
annotate("text", x= 5.5, y=0.78, label="警告域\n|z|≥3", size=2.8, color="#E74C3C", fontface="italic", vjust=0) +
scale_x_continuous(limits=c(-4, x_max), breaks=seq(-3, 7, by=1)) +
scale_color_manual(values=c("FALSE"=col_normal,"TRUE"=col_mirai), guide="none") +
scale_fill_manual(values =c("FALSE"=col_normal,"TRUE"=col_mirai), guide="none") +
scale_shape_manual(values=c("FALSE"=21,"TRUE"=23), guide="none") +
labs(title="標準化残差(z スコア)",
subtitle="各政党の観測値がモデルの予測から何σ(標準偏差)離れているか ▶ = 軸外へ突き抜け",
x="z スコア", y=NULL) +
theme_minimal(base_size=12) +
theme(
plot.title=element_text(face="bold"),
plot.subtitle=element_text(color="#555555"),
panel.grid.minor=element_blank(),
panel.grid.major.y=element_blank(),
axis.text.y = element_text(size = 10.5)
)z スコアとは
「平均から何標準偏差(σ)離れているか」を表す数値です。
zt <- intervals_tbl %>%
arrange(desc(z残差)) %>%
mutate(
`z スコア` = round(z残差, 2),
評価 = case_when(
abs(z残差) > 3 ~ "★★★ |z|>3(警告)",
abs(z残差) > 2 ~ "★★ |z|>2(注意)",
TRUE ~ "正常域"
)
) %>%
select(政党, `z スコア`, 評価)
datatable(
zt,
caption = "政党別 z スコア",
rownames = FALSE,
options = list(pageLength = 10, dom = "t", ordering = FALSE),
class = "stripe hover compact"
) %>%
formatStyle(
"政党",
target = "row",
backgroundColor = styleEqual("チームみらい", "#FDECEA"),
color = styleEqual("チームみらい", "#C0392B"),
fontWeight = styleEqual("チームみらい", "bold")
) %>%
formatStyle(
"z スコア",
background = styleInterval(c(-3, -2, 2, 3),
c("#FADBD8","#FDEBD0","#EAFAF1","#FDEBD0","#FADBD8")),
fontWeight = "bold"
)チームみらいの z スコアは 6.49 です。 他の全政党が −0.9〜+1.3 の正常域に収まっている一方、チームみらいだけが6σ超の異常値を示しています。 このような外れ値が偶然起きる確率は、正規分布で計算すると10億分の1以下です。
p3_data <- intervals_tbl %>%
mutate(
pct_label = sprintf("%.1f%%ile", pctile * 100),
政党_p = fct_reorder(政党, pctile)
)
plvls3 <- levels(p3_data$政党_p)
ggplot(p3_data, aes(x=pctile*100, y=政党_p)) +
annotate("rect", xmin= 0, xmax=90, ymin=-Inf, ymax=Inf, fill="#EAFAF1", alpha=0.4) +
annotate("rect", xmin=90, xmax=95, ymin=-Inf, ymax=Inf, fill="#FDEBD0", alpha=0.5) +
annotate("rect", xmin=95, xmax=100, ymin=-Inf, ymax=Inf, fill="#FADBD8", alpha=0.6) +
geom_vline(xintercept=c(90,95,99),
linetype="dashed",
color=c("#F39C12","#E74C3C","#922B21"),
linewidth=0.8) +
geom_col(aes(fill=is_mirai), width=0.65, alpha=0.88) +
# pctile > 0.85 は内側に白文字、それ以外は外側に政党カラー文字
geom_text(
data = filter(p3_data, pctile <= 0.85),
aes(label=pct_label, y=政党_p),
x=0, hjust=-0.1, size=3.5, color=col_normal, inherit.aes=FALSE
) +
geom_text(
data = filter(p3_data, pctile > 0.85),
aes(label=pct_label, x=pctile*100, y=政党_p,
color=is_mirai),
hjust=1.1, size=3.5,
fontface=ifelse(filter(p3_data, pctile>0.85)$is_mirai,"bold","plain"),
# バー内のテキスト色:チームみらい(赤バー)は白、それ以外は白
color="white", inherit.aes=FALSE
) +
annotate("text", x=92, y=0.78, label="p=0.10", size=2.8, color="#E67E22", angle=90, vjust=0) +
annotate("text", x=97, y=0.78, label="p=0.05", size=2.8, color="#E74C3C", angle=90, vjust=0) +
annotate("text", x=99.5, y=0.78, label="p=0.01", size=2.8, color="#922B21", angle=90, vjust=0) +
scale_x_continuous(limits=c(0,101), labels=function(x) paste0(x,"%")) +
scale_fill_manual(values=c("FALSE"="#5D8AA8","TRUE"=col_mirai), guide="none") +
scale_color_manual(values=c("FALSE"=col_normal,"TRUE"=col_mirai), guide="none") +
labs(title="観測値の事後予測パーセンタイル",
subtitle="観測値が予測分布の何番目に相当するか(100番目 = 予測を大きく超えた)",
x="パーセンタイル(%)", y=NULL) +
theme_minimal(base_size=12) +
theme(
plot.title=element_text(face="bold"),
plot.subtitle=element_text(color="#555555"),
panel.grid.minor=element_blank(),
panel.grid.major.y=element_blank(),
axis.text.y = element_text(size = 10.5)
)パーセンタイルの意味
このグラフは「モデルが生成した10万個の予測値のうち、何%が実際の観測値より小さいか」を表しています。
例:参政党が20.4%ile → 予測値の20.4%が参政党の実際の得票率より低かった = 観測値は予測の中間あたりにある = 普通
例:チームみらいが99.8%ile → 予測値の99.8%がチームみらいの実際の得票率より低かった = 観測値はほぼ予測の最大値を超えている
言い換えると、片側の Bayesian p値 = 1 − パーセンタイルです。
pt <- intervals_tbl %>%
arrange(desc(pctile)) %>%
mutate(
パーセンタイル = sprintf("%.1f%%ile", pctile * 100),
`Bayesian p値` = round(1 - pctile, 4),
評価 = case_when(
(1 - pctile) < 0.01 ~ "★★★ p<0.01(高度に有意)",
(1 - pctile) < 0.05 ~ "★★ p<0.05(有意)",
(1 - pctile) < 0.10 ~ "★ p<0.10(傾向あり)",
TRUE ~ "有意差なし"
)
) %>%
select(政党, パーセンタイル, `Bayesian p値`, 評価)
datatable(
pt,
caption = "政党別 事後予測パーセンタイル",
rownames = FALSE,
options = list(pageLength = 10, dom = "t", ordering = FALSE),
class = "stripe hover compact"
) %>%
formatStyle(
"政党",
target = "row",
backgroundColor = styleEqual("チームみらい", "#FDECEA"),
color = styleEqual("チームみらい", "#C0392B"),
fontWeight = styleEqual("チームみらい", "bold")
) %>%
formatStyle(
"Bayesian p値",
background = styleInterval(c(0.01, 0.05, 0.1),
c("#FADBD8","#FDEBD0","#FFF3CD","white")),
fontWeight = "bold"
)n_draw <- 30000
dens_data <- merged %>%
rowwise() %>%
mutate(
pred_samples = list({
pl <- samples$alpha + samples$beta * log(支持率)
ss <- exp(samples$log_sigma)
exp(rnorm(n_draw, pl, ss))
})
) %>%
unnest(pred_samples) %>%
rename(pred = pred_samples) %>%
ungroup() %>%
mutate(is_mirai = 政党 == "チームみらい")
party_dens_order <- merged %>%
arrange(desc(東京平均得票率)) %>%
pull(政党)
dens_data <- dens_data %>%
mutate(政党_d = factor(政党, levels = party_dens_order)) %>%
# 各政党の予測を「観測値の3倍 または 99パーセンタイル」でクリップ
group_by(政党) %>%
mutate(
clip_max = max(quantile(pred, 0.99),
東京平均得票率 * 1.5)
) %>%
filter(pred <= clip_max) %>%
ungroup()
ggplot(dens_data, aes(x = pred)) +
geom_density(aes(fill=is_mirai, color=is_mirai),
alpha=0.35, linewidth=0.7, trim=TRUE) +
geom_vline(
data = merged %>%
mutate(is_mirai=政党=="チームみらい",
政党_d=factor(政党, levels=party_dens_order)),
aes(xintercept=東京平均得票率, color=is_mirai),
linewidth=1.1, linetype="dashed"
) +
geom_text(
data = merged %>%
mutate(is_mirai=政党=="チームみらい",
政党_d=factor(政党, levels=party_dens_order)),
aes(x=東京平均得票率, y=Inf,
label=sprintf("観測\n%.1f%%", 東京平均得票率),
color=is_mirai),
vjust=1.3, hjust=-0.08, size=3, fontface="bold", inherit.aes=FALSE
) +
facet_wrap(~政党_d, scales="free", ncol=3) +
scale_x_continuous(labels=function(x) paste0(x,"%")) +
scale_fill_manual(values=c("FALSE"="#5D8AA8","TRUE"=col_mirai),
labels=c("FALSE"="その他政党","TRUE"="チームみらい"), name=NULL) +
scale_color_manual(values=c("FALSE"="#2C5F7A","TRUE"=col_mirai), guide="none") +
labs(title="政党別 事後予測分布と観測値",
subtitle="塗り = モデルが予測する分布 破線 = 実際の観測値",
x="東京比例 平均得票率(%)", y="密度") +
theme_minimal(base_size=10.5) +
theme(
plot.title=element_text(face="bold", size=13),
legend.position="top",
strip.text=element_text(
face = ifelse(party_dens_order=="チームみらい","bold","plain"),
color = ifelse(party_dens_order=="チームみらい",col_mirai,col_normal),
size = 10
),
panel.grid.minor=element_blank()
)このグラフの見方
各政党のパネルで: - 塗りつぶした山:モデルが「おそらくこの範囲に収まるだろう」と予測した分布 - 破線:実際の観測値
ほとんどの政党では、破線が山の中(密度の高いところ)に位置しています。予測が当たっているということです。
チームみらい(右上の赤いパネル)では、密度の山は0〜5%あたりにありますが、観測値の破線は12.2%で山のほぼ右端にあります。モデルの予測からかけ離れた値が実現しています。
wf_data <- intervals_tbl %>%
mutate(
予測倍率 = `q0.5` / 支持率,
全体倍率 = 東京平均得票率 / 支持率,
政党_w = fct_reorder(政党, -全体倍率)
)
wlvls <- levels(wf_data$政党_w)
ggplot(wf_data, aes(y = 政党_w)) +
geom_col(aes(x = 予測倍率), fill = "#AED6F1", width=0.6, alpha=0.8) +
geom_col(aes(x = 全体倍率), fill = col_mirai, width=0.6, alpha=0.85) +
geom_text(aes(x = 全体倍率,
label = sprintf("×%.1f", 全体倍率)),
hjust=-0.12, size=3.5,
color = col_normal,
fontface=ifelse(wf_data$is_mirai,"bold","plain")) +
geom_vline(xintercept=mean(wf_data$予測倍率),
linetype="dashed", color="#2C5F7A", linewidth=0.8) +
annotate("text",
x=mean(wf_data$予測倍率)+0.3, y=0.4,
label=sprintf("予測倍率\n平均 ×%.1f", mean(wf_data$予測倍率)),
hjust=0, size=3.0, color="#2C5F7A") +
scale_color_manual(values=c("FALSE"=col_normal,"TRUE"=col_mirai), guide="none") +
scale_x_continuous(labels=function(x) paste0("×",x), limits=c(0,76)) +
labs(title="支持率からの増幅倍率の分解",
subtitle="青(薄)= モデルが説明できる増幅(全政党で共通) 赤 = モデルで説明できない乖離",
x="倍率(東京実得票率 ÷ 世論調査支持率)", y=NULL) +
theme_minimal(base_size=12) +
theme(
plot.title=element_text(face="bold"),
plot.subtitle=element_text(color="#555555"),
panel.grid.minor=element_blank(),
panel.grid.major.y=element_blank(),
axis.text.y = element_text(size = 10.5)
)倍率の2層構造
すべての政党で「支持率→東京得票率」に増幅が起きます(東京は支持率調査より本番の方が高くなりやすい)。 これはモデルが説明できる増幅(青い部分)です。
チームみらいは、その「説明できる増幅」を大きく上回る乖離があります。 青の部分はわずかで、残りの大部分がモデルで説明できない赤い部分です。
他党がすべて×1.5〜×5.6の範囲に収まっているのに、チームみらいだけ×61という異常値です。
mirai_pv_fmt <- sprintf("%.4f", mirai_pv)
mirai_pctile_fmt <- sprintf("%.1f", mirai_row$pctile * 100)
mirai_z_fmt <- sprintf("%.2f", mirai_z)
cat(sprintf(
'<div class="callout-result">
<strong>Bayesian 事後予測 p 値 = %s(★★ p < 0.01)</strong><br><br>
チームみらいの観測値(12.2%%)は、事後予測分布の <strong>%s%%ile</strong> に相当します。<br>
これは、モデルが生成した予測のうち <strong>%s%%</strong> がチームみらいの実際の得票率を下回っていたことを意味します。<br><br>
z スコア = <strong>%s σ</strong>——「支持率0.2%%の政党が得票率12.2%%を取る」という事象は、
モデルから %s 標準偏差離れた位置にある極端な外れ値です。
</div>',
mirai_pv_fmt, mirai_pctile_fmt,
mirai_pctile_fmt, mirai_z_fmt, mirai_z_fmt
))Bayesian 事後予測 p 値 = 0.0010(★★ p <
0.01)
チームみらいの観測値(12.2%)は、事後予測分布の
99.9%ile に相当します。
これは、モデルが生成した予測のうち 99.9%
がチームみらいの実際の得票率を下回っていたことを意味します。
z
スコア = 6.49
σ——「支持率0.2%の政党が得票率12.2%を取る」という事象は、
モデルから 6.49 標準偏差離れた位置にある極端な外れ値です。
st <- tibble(
グラフ = paste0("Graph ", 1:5),
分析手法 = c(
"事後予測区間 vs 観測値",
"標準化残差(z スコア)",
"事後予測パーセンタイル",
"政党別予測密度 小倍図",
"支持率増幅倍率の分解"
),
チームみらいの結果 = c(
"95%予測区間(0.30〜3.66%)を大きく超える 12.22%",
sprintf("z = %.2f σ(他全政党は −0.9〜+1.3 の正常域)", mirai_z),
sprintf("%.1f%%ile(p ≈ %.4f)", mirai_row$pctile*100, 1-mirai_row$pctile),
"密度の山が 0〜3% に集中、観測値 12.2% は山のほぼ外",
"他党 ×1.5〜5.6 に対してチームみらいは ×61.1"
),
判定 = rep("★★★ 異常", 5)
)
datatable(
st,
caption = "5つの事後予測チェックの結果サマリー",
rownames = FALSE,
options = list(pageLength = 5, dom = "t", ordering = FALSE),
class = "stripe hover compact"
) %>%
formatStyle(
"判定",
color = "#C0392B",
backgroundColor = "#FDECEA",
fontWeight = "bold",
textAlign = "center"
)重要な注意:統計的異常は「不正の証拠」ではない
以下の「自然な説明」が成立するなら、今回の結果は異常でない可能性があります。 これらの仮説を検証してこそ、分析が完結します。
tibble(
No. = 1:4,
対抗仮説 = c(
"安野貴博の東京知名度効果",
"東京の特殊な有権者構成",
"世論調査自体の偏り",
"投票先の戦略的シフト"
),
内容 = c(
"チームみらい代表・安野貴博氏は2024年東京都知事選に出馬(約16万票)。東京でのみ高い知名度が東京の得票を押し上げた可能性がある",
"東京はIT・高学歴・若年層が集中しており、チームみらいの政策(テクノロジー・デジタル改革)と親和性が高い有権者層が多い可能性がある",
"時事通信の電話調査は高齢者・固定電話保有者に偏りがちで、チームみらいの主要支持層(若年・スマートフォン中心)が過小代表の可能性がある",
"比例投票では「死票を避けて当選確実な政党に入れる」戦略が見られることがあり、東京でのみ集中投票があった可能性"
),
反証可能性 = c(
"都知事選の区別得票と今回の区別得票の相関を確認すれば検証できる",
"他都市(大阪・名古屋など)のチームみらい得票率と比較すれば検証できる",
"ネット調査・出口調査と比較することで偏りの大きさを推定できる",
"選挙前のネット上の動員活動記録、SNS投稿の分析で検証できる"
)
) %>%
datatable(
rownames = FALSE,
options = list(pageLength = 5, dom = "t", ordering = FALSE, scrollX = TRUE),
class = "stripe hover compact"
) %>%
formatStyle("No.", textAlign = "center", fontWeight = "bold") %>%
formatStyle("対抗仮説", fontWeight = "bold")alpha_med <- median(samples$alpha)
beta_med <- median(samples$beta)
y_obs <- log(merged$東京平均得票率[merged$is_mirai])
p05 <- exp((y_obs - 1.645 * sigma_med - alpha_med) / beta_med)
p01 <- exp((y_obs - 2.326 * sigma_med - alpha_med) / beta_med)
p001 <- exp((y_obs - 3.090 * sigma_med - alpha_med) / beta_med)チームみらいの東京得票率12.2%が「統計的に驚くべきではない(p≥0.05)」と言えるためには、世論調査支持率が 2.2% 以上 である必要があります。
tibble(
有意水準 = c("p < 0.05\n(有意)", "p < 0.01\n(高度に有意)", "p < 0.001\n(極めて有意)"),
必要支持率 = c(p05, p01, p001),
実際の支持率 = 0.2
) %>%
mutate(有意水準 = factor(有意水準, levels = 有意水準)) %>%
ggplot(aes(y = 有意水準)) +
geom_col(aes(x = 必要支持率), fill = "#5D8AA8", width = 0.5, alpha = 0.8) +
geom_col(aes(x = 実際の支持率), fill = col_mirai, width = 0.5, alpha = 0.9) +
geom_text(aes(x = 必要支持率,
label = sprintf("必要支持率: %.2f%%", 必要支持率)),
hjust = -0.1, size = 3.8) +
geom_vline(xintercept = 0.2, linetype = "dashed",
color = col_mirai, linewidth = 1) +
annotate("text", x = 0.2, y = 3.5,
label = "実際の支持率\n0.2%",
color = col_mirai, size = 3.2, hjust = 1.1, fontface = "bold") +
scale_x_continuous(limits = c(0, 5),
labels = function(x) paste0(x, "%")) +
labs(title = "「観測値が有意でなくなる」ために必要な支持率",
subtitle = "青 = 必要支持率 赤線 = 実際の支持率(0.2%)",
x = "支持率(%)", y = NULL) +
theme_minimal(base_size = 12) +
theme(plot.title = element_text(face = "bold"),
panel.grid.major.y = element_blank(),
panel.grid.minor = element_blank())p < 0.05 の閾値を満たすだけでも、実際の支持率(0.2%)の 11倍の支持率が必要です。 「世論調査の誤差」で埋められる差ではありません。
tibble(
項目 = c(
"支持率 → 実得票率 の倍率",
"他党との比較(倍率)",
"z スコア(事後予測)",
"事後予測パーセンタイル",
"Bayesian p値(片側)",
"「普通」と言えるための支持率"
),
値 = c(
"× 61.1(支持率0.2% → 得票率12.2%)",
"他党は × 1.5〜5.6 の範囲",
sprintf("%.2f σ(他全政党は −0.9〜+1.3)", mirai_z),
sprintf("%.1f%%ile", mirai_row$pctile * 100),
sprintf("p = %.4f(p < 0.01)", 1 - mirai_row$pctile),
sprintf("最低 %.2f%% 必要(実際の11倍以上)", p05)
),
評価 = c("★★★", "★★★", "★★★", "★★★", "★★", "★★★")
) %>%
datatable(
rownames = FALSE,
options = list(pageLength = 10, dom = "t", ordering = FALSE),
class = "stripe hover compact"
) %>%
formatStyle("項目", fontWeight = "bold") %>%
formatStyle("評価",
fontWeight = "bold", textAlign = "center",
color = "#C0392B", backgroundColor = "#FDECEA"
)統計的結論
5つの独立した視点からの事後予測チェックのすべてにおいて、チームみらいの得票率は 「支持率0.2%の政党として自然に期待される値」から 極めて大きく乖離 しています。
Bayesian p 値 = 0.0010(p < 0.01) z スコア = 6.49 σ
このレベルの乖離は、モデルのばらつきや東京の地域特性だけでは説明しにくいです。
ただし、本分析の限界
本分析単独で「不正の証明」にはならない 統計的異常 = 異常なことが起きた可能性が高い、という示唆に過ぎません。
対抗仮説が否定できていない 安野貴博の東京知名度効果・有権者構成の偏り・世論調査自体の偏りを定量的に排除できれば、分析の信頼性は格段に上がります。
東京都のデータのみ 他都道府県でも同様の乖離があるかどうかを確認することが、次の重要なステップです。
世論調査と実選挙の乖離は常にある 今回のモデルは「乖離の大きさに上限がある」という暗黙の前提を置いています。 まったく新しい政党・候補者の場合、世論調査が実態を大きく見誤ることもあり得ます。
分析実施日: 2026-02-12 / データ: 2026_衆院選_比例_東京_r.xlsx(出典: 東京都選挙管理委員会 r08shu_hkai_036.pdf)/ 時事通信世論調査(2026年1月15日時点)